home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-mh-e.el.z / tm-mh-e.el
Encoding:
Text File  |  1998-05-21  |  11.2 KB  |  418 lines
  1. ;;; tm-mh-e.el --- MIME extension for mh-e
  2.  
  3. ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
  7. ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  8. ;; Created: 1993/11/21 (obsolete mh-e-mime.el)
  9. ;; Version: $Revision: 7.73 $
  10. ;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual
  11.  
  12. ;; This file is part of tm (Tools for MIME).
  13.  
  14. ;; This program is free software; you can redistribute it and/or
  15. ;; modify it under the terms of the GNU General Public License as
  16. ;; published by the Free Software Foundation; either version 2, or (at
  17. ;; your option) any later version.
  18.  
  19. ;; This program is distributed in the hope that it will be useful, but
  20. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22. ;; General Public License for more details.
  23.  
  24. ;; You should have received a copy of the GNU General Public License
  25. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27. ;; Boston, MA 02111-1307, USA.
  28.  
  29. ;;; Code:
  30.  
  31. (require 'tl-str)
  32. (require 'tl-misc)
  33. (require 'mh-e)
  34. (or (featurep 'mh-utils)
  35.     (require 'tm-mh-e3)
  36.     )
  37. (require 'tm-view)
  38.  
  39. (or (fboundp 'mh-get-header-field)
  40.     (defalias 'mh-get-header-field 'mh-get-field)
  41.     )
  42. (or (boundp 'mh-temp-buffer)
  43.     (defconst mh-temp-buffer " *mh-temp*")
  44.     )
  45.  
  46.  
  47. ;;; @ version
  48. ;;;
  49.  
  50. (defconst tm-mh-e/RCS-ID
  51.   "$Id: tm-mh-e.el,v 7.73 1996/12/12 05:15:55 morioka Exp $")
  52.  
  53. (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
  54.  
  55.  
  56. ;;; @ variable
  57. ;;;
  58.  
  59. (defvar tm-mh-e/automatic-mime-preview t
  60.   "*If non-nil, show MIME processed message.")
  61.  
  62. (defvar tm-mh-e/decode-encoded-word t
  63.   "*If non-nil, decode encoded-word when it is not MIME preview mode.")
  64.  
  65.  
  66. ;;; @ functions
  67. ;;;
  68.  
  69. (defun mh-display-msg (msg-num folder &optional show-buffer mode)
  70.   (or mode
  71.       (setq mode tm-mh-e/automatic-mime-preview)
  72.       )
  73.   ;; Display message NUMBER of FOLDER.
  74.   ;; Sets the current buffer to the show buffer.
  75.   (set-buffer folder)
  76.   (or show-buffer
  77.       (setq show-buffer mh-show-buffer))
  78.   ;; Bind variables in folder buffer in case they are local
  79.   (let ((formfile mhl-formfile)
  80.     (clean-message-header mh-clean-message-header)
  81.     (invisible-headers mh-invisible-headers)
  82.     (visible-headers mh-visible-headers)
  83.     (msg-filename (mh-msg-filename msg-num))
  84.     )
  85.     (if (not (file-exists-p msg-filename))
  86.     (error "Message %d does not exist" msg-num))
  87.     (set-buffer show-buffer)
  88.     (cond ((not (equal msg-filename buffer-file-name))
  89.        ;; Buffer does not yet contain message.
  90.        (mh-unvisit-file)
  91.        (setq buffer-read-only nil)
  92.        (erase-buffer)
  93.        ;; Changing contents, so this hook needs to be reinitialized.
  94.        ;; pgp.el uses this.
  95.        (if (boundp 'write-contents-hooks) ;Emacs 19
  96.            (setq write-contents-hooks nil))
  97.        (if mode
  98.            (let* ((aname (concat "article-" folder))
  99.               (abuf (get-buffer aname))
  100.               )
  101.          (if abuf
  102.              (progn
  103.                (set-buffer abuf)
  104.                (setq buffer-read-only nil)
  105.                (erase-buffer)
  106.                )
  107.            (setq abuf (get-buffer-create aname))
  108.            (set-buffer abuf)
  109.            )
  110.          (as-binary-input-file
  111.           (insert-file-contents msg-filename)
  112.           ;; (goto-char (point-min))
  113.           (while (re-search-forward "\r$" nil t)
  114.             (replace-match "")
  115.             )
  116.           )
  117.          (set-buffer-modified-p nil)
  118.          (setq buffer-read-only t)
  119.          (setq buffer-file-name msg-filename)
  120.          (mh-show-mode)
  121.          (save-excursion
  122.            (let ( (buffer-read-only nil) )
  123.              (cond (clean-message-header
  124.                 (mh-clean-msg-header (point-min)
  125.                          invisible-headers
  126.                          visible-headers)
  127.                 (goto-char (point-min)))
  128.                (t
  129.                 (mh-start-of-uncleaned-message)))))
  130.          (mime/viewer-mode nil nil nil
  131.                    aname (concat "show-" folder))
  132.          (goto-char (point-min))
  133.          )
  134.          (progn
  135.            (if formfile
  136.            (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
  137.                        (if (stringp formfile)
  138.                            (list "-form" formfile))
  139.                        msg-filename)
  140.          (insert-file-contents msg-filename))
  141.            ;; end
  142.            (goto-char (point-min))
  143.            (cond (clean-message-header
  144.               (mh-clean-msg-header (point-min)
  145.                        invisible-headers
  146.                        visible-headers)
  147.               (goto-char (point-min)))
  148.              (t
  149.               (mh-start-of-uncleaned-message)))
  150.            (if tm-mh-e/decode-encoded-word
  151.            (mime/decode-message-header)
  152.          )
  153.            (setq buffer-read-only t)
  154.            (setq buffer-file-name msg-filename)
  155.            (mh-show-mode)
  156.            ))
  157.        (set-buffer-modified-p nil)
  158.        (or (eq buffer-undo-list t)    ;don't save undo info for prev msgs
  159.            (setq buffer-undo-list nil))
  160.        (set-buffer-auto-saved)
  161.        ;; the parts of set-visited-file-name we want to do (no locking)
  162.        (setq buffer-file-name msg-filename)
  163.        (setq buffer-backed-up nil)
  164.        (auto-save-mode 1)
  165.        (set-mark nil)
  166.        (setq mode-line-buffer-identification
  167.          (list (format mh-show-buffer-mode-line-buffer-id
  168.                    folder msg-num)))
  169.        (set-buffer folder)
  170.        (setq mh-showing-with-headers nil)))))
  171.  
  172. (defun tm-mh-e/view-message (&optional msg)
  173.   "MIME decode and play this message."
  174.   (interactive)
  175.   (if (or (null tm-mh-e/automatic-mime-preview)
  176.       (null (get-buffer mh-show-buffer))
  177.       (save-excursion
  178.         (set-buffer mh-show-buffer)
  179.         (not (eq major-mode 'mime/viewer-mode))
  180.         ))
  181.       (let ((tm-mh-e/automatic-mime-preview t))
  182.     (mh-invalidate-show-buffer)
  183.     (mh-show-msg msg)
  184.     ))
  185.   (pop-to-buffer mh-show-buffer)
  186.   )
  187.  
  188. (defun tm-mh-e/toggle-decoding-mode (arg)
  189.   "Toggle MIME processing mode.
  190. With arg, turn MIME processing on if arg is positive."
  191.   (interactive "P")
  192.   (setq tm-mh-e/automatic-mime-preview
  193.     (if (null arg)
  194.         (not tm-mh-e/automatic-mime-preview)
  195.       arg))
  196.   (save-excursion
  197.     (set-buffer mh-show-buffer)
  198.     (if (null tm-mh-e/automatic-mime-preview)
  199.     (if (and mime::preview/article-buffer
  200.          (get-buffer mime::preview/article-buffer))
  201.         (kill-buffer mime::preview/article-buffer)
  202.       )))
  203.   (mh-invalidate-show-buffer)
  204.   (mh-show (mh-get-msg-num t))
  205.   )
  206.  
  207. (defun tm-mh-e/show (&optional message)
  208.   (interactive)
  209.   (mh-invalidate-show-buffer)
  210.   (mh-show message)
  211.   )
  212.  
  213. (defun tm-mh-e/header-display ()
  214.   (interactive)
  215.   (mh-invalidate-show-buffer)
  216.   (let ((mime-viewer/ignored-field-regexp "^:$")
  217.     tm-mh-e/decode-encoded-word)
  218.     (mh-header-display)
  219.     ))
  220.  
  221. (defun tm-mh-e/raw-display ()
  222.   (interactive)
  223.   (mh-invalidate-show-buffer)
  224.   (let (tm-mh-e/automatic-mime-preview
  225.     tm-mh-e/decode-encoded-word)
  226.     (mh-header-display)
  227.     ))
  228.  
  229. (defun tm-mh-e/burst-multipart/digest ()
  230.   "Burst apart the current message, which should be a multipart/digest.
  231. The message is replaced by its table of contents and the letters from the
  232. digest are inserted into the folder after that message."
  233.   (interactive)
  234.   (let ((digest (mh-get-msg-num t)))
  235.     (mh-process-or-undo-commands mh-current-folder)
  236.     (mh-set-folder-modified-p t)        ; lock folder while bursting
  237.     (message "Bursting digest...")
  238.     (mh-exec-cmd "mhn" "-store" mh-current-folder digest)
  239.     (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
  240.     (message "Bursting digest...done")
  241.     ))
  242.  
  243.  
  244. ;;; @ for tm-view
  245. ;;;
  246.  
  247. (fset 'tm-mh-e/decode-charset-buffer
  248.       (symbol-function 'mime-charset/decode-buffer))
  249.  
  250. (set-alist 'mime-viewer/code-converter-alist
  251.        'mh-show-mode
  252.        (function tm-mh-e/decode-charset-buffer))
  253.  
  254. (defun tm-mh-e/content-header-filter ()
  255.   (goto-char (point-min))
  256.   (mime-preview/cut-header)
  257.   (tm-mh-e/decode-charset-buffer default-mime-charset)
  258.   (mime/decode-message-header)
  259.   )
  260.  
  261. (set-alist 'mime-viewer/content-header-filter-alist
  262.        'mh-show-mode
  263.        (function tm-mh-e/content-header-filter))
  264.  
  265. (defun tm-mh-e/quitting-method ()
  266.   (let ((win (get-buffer-window
  267.           mime/output-buffer-name))
  268.     (buf (current-buffer))
  269.     )
  270.     (if win
  271.     (delete-window win)
  272.       )
  273.     (pop-to-buffer
  274.      (let ((name (buffer-name buf)))
  275.        (substring name 5)
  276.        ))
  277.     (if (not tm-mh-e/automatic-mime-preview)
  278.     (mh-invalidate-show-buffer)
  279.       )
  280.     (mh-show (mh-get-msg-num t))
  281.     ))
  282.  
  283. (set-alist 'mime-viewer/quitting-method-alist
  284.        'mh-show-mode
  285.        (function tm-mh-e/quitting-method))
  286. (set-alist 'mime-viewer/show-summary-method
  287.        'mh-show-mode
  288.        (function tm-mh-e/quitting-method))
  289.  
  290. (defun tm-mh-e/following-method (buf)
  291.   (save-excursion
  292.     (set-buffer buf)
  293.     (goto-char (point-max))
  294.     (setq mh-show-buffer buf)
  295.     (apply (function mh-send)
  296.        (std11-field-bodies '("From" "cc" "Subject") ""))
  297.     (setq mh-sent-from-folder buf)
  298.     (setq mh-sent-from-msg 1)
  299.     (let ((last (point)))
  300.       (mh-yank-cur-msg)
  301.       (goto-char last)
  302.       )))
  303.  
  304. (set-alist 'mime-viewer/following-method-alist
  305.        'mh-show-mode
  306.        (function tm-mh-e/following-method))
  307.  
  308.  
  309. ;;; @@ for tm-partial
  310. ;;;
  311.  
  312. (call-after-loaded
  313.  'tm-partial
  314.  (function
  315.   (lambda ()
  316.     (set-atype 'mime/content-decoding-condition
  317.            '((type . "message/partial")
  318.          (method . mime-article/grab-message/partials)
  319.          (major-mode . mh-show-mode)
  320.          (summary-buffer-exp
  321.           . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
  322.                  (string-match "^show-\\(.+\\)$" article-buffer))
  323.              (substring article-buffer
  324.                     (match-beginning 1) (match-end 1))
  325.              ))
  326.          ))
  327.     (set-alist 'tm-partial/preview-article-method-alist
  328.            'mh-show-mode
  329.            (function
  330.         (lambda ()
  331.           (let ((tm-mh-e/automatic-mime-preview t))
  332.             (tm-mh-e/show)
  333.             ))))
  334.     )))
  335.  
  336.  
  337. ;;; @ set up
  338. ;;;
  339.  
  340. (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
  341. (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
  342. (define-key mh-folder-mode-map "." (function tm-mh-e/show))
  343. (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
  344. (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
  345. (define-key mh-folder-mode-map "\C-c\C-b"
  346.   (function tm-mh-e/burst-multipart/digest))
  347.  
  348. (defun tm-mh-e/summary-before-quit ()
  349.   (let ((buf (get-buffer mh-show-buffer)))
  350.     (if buf
  351.     (let ((the-buf (current-buffer)))
  352.       (switch-to-buffer buf)
  353.       (if (and mime::article/preview-buffer
  354.            (setq buf (get-buffer mime::article/preview-buffer))
  355.            )
  356.           (progn
  357.         (switch-to-buffer the-buf)
  358.         (kill-buffer buf)
  359.         )
  360.         (switch-to-buffer the-buf)
  361.         )
  362.       ))))
  363.  
  364. (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
  365.          
  366.  
  367. ;;; @@ for tmh-comp.el
  368. ;;;
  369.  
  370. (autoload 'tm-mh-e/edit-again "tmh-comp"
  371.   "Clean-up a draft or a message previously sent and make it resendable." t)
  372. (autoload 'tm-mh-e/extract-rejected-mail "tmh-comp"
  373.   "Extract a letter returned by the mail system and make it re-editable." t)
  374. (autoload 'tm-mh-e/forward "tmh-comp"
  375.   "Forward a message or message sequence by MIME style." t)
  376.  
  377. (call-after-loaded
  378.  'mime-setup
  379.  (function
  380.   (lambda ()
  381.     (substitute-key-definition
  382.      'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map)
  383.     (substitute-key-definition
  384.      'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail
  385.      mh-folder-mode-map)
  386.     (substitute-key-definition
  387.      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
  388.  
  389.     (call-after-loaded
  390.      'mh-comp
  391.      (function
  392.       (lambda ()
  393.     (require 'tmh-comp)
  394.     ))
  395.      'mh-letter-mode-hook)
  396.     )))
  397.  
  398.  
  399. ;;; @ for BBDB
  400. ;;;
  401.  
  402. (call-after-loaded
  403.  'bbdb
  404.  (function
  405.   (lambda ()
  406.     (require 'tm-bbdb)
  407.     )))
  408.  
  409.  
  410. ;;; @ end
  411. ;;;
  412.  
  413. (provide 'tm-mh-e)
  414.  
  415. (run-hooks 'tm-mh-e-load-hook)
  416.  
  417. ;;; tm-mh-e.el ends here
  418.